home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RTT.ZIP / RTTINLIN.C < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-10  |  58.8 KB  |  1,738 lines
  1. /*
  2.  * rttinlin.c contains routines which produce the in-line version of an
  3.  *  operation and put it in the data base.
  4.  */
  5. #include "rtt.h"
  6.  
  7. /*
  8.  * prototypes for static functions. 
  9.  */
  10. hidden int             body_anlz Params((struct node *n, int *does_break,
  11.                                    int may_mod));
  12. hidden struct il_code *body_fnc  Params((struct node *n));
  13. hidden novalue         chkrettyp Params((struct node *n));
  14. hidden novalue         chng_ploc Params((struct node *cnv_typ,
  15.                                    struct node *src));
  16. hidden novalue         cnt_bufs  Params((struct node *cnv_typ));
  17. hidden int             icn_typ   Params((struct node *n));
  18. hidden struct il_code *il_walk   Params((struct node *n));
  19. hidden struct il_code *il_var    Params((struct node *n));
  20. hidden int             is_addr   Params((struct node *dcltor, int modifier));
  21. hidden novalue         lcl_tend  Params((struct node *n));
  22. hidden int             mrg_abstr Params((int sum, int typ));
  23. hidden int             strct_typ Params((struct node *typ, int *is_reg));
  24.  
  25. static int body_ret; /* RetInt, RetDbl, and/or RetOther for current body */
  26. static int ret_flag; /* DoesFail, DoesRet, and/or DoesSusp for current body */
  27. int fnc_ret;         /* RetInt, RetDbl, RetNoVal, or RetSig for current func */
  28.  
  29. #ifndef Rttx
  30.  
  31. /*
  32.  * body_prms is a list of symbol table entries for identifiers that must
  33.  *  be passed as parameters to the function implementing the current
  34.  *  body statement. The id_type of an identifier may be changed in the
  35.  *  symbol table while the body function is being produced; for example,
  36.  *  a tended descriptor is accessed through a parameter that is a pointer
  37.  *  to a descriptor, rather than being accessed as an element of a descriptor
  38.  *  array in a struct.
  39.  */
  40. struct var_lst {
  41.    struct sym_entry *sym;
  42.    int id_type;            /* saved value of id_type from sym */
  43.    struct var_lst *next;
  44.    };
  45. struct var_lst *body_prms;
  46. static struct var_lst *v_lst_free = NULL; /* free list for var_lst structs */
  47. int n_bdy_prms;        /* number of entries in body_prms list */
  48. int rslt_loc;        /* flag: function passed addr of result descriptor */
  49.  
  50. char prfx3;        /* 3rd prefix char; used for unique body func names */
  51.  
  52. /*
  53.  * in_line - place in the data base in-line code for an operation and
  54.  *   produce C functions for body statements.
  55.  */
  56. novalue in_line(n)
  57. struct node *n;
  58.    {
  59.    struct sym_entry *sym;
  60.    int i;
  61.    int nvars;
  62.    int ntend;
  63.  
  64.    prfx3 = ' '; /* reset 3rd prefix char for body functions */
  65.  
  66.    /*
  67.     * Set up the local symbol table in the data base for the in-line code.
  68.     *  This symbol table has an array of entries for the tended variables
  69.     *  in the declare statement, if there is one. Determine how large the
  70.     *  array must be and create it.
  71.     */
  72.    ntend = 0;
  73.    for (sym = dcl_stk->tended; sym != NULL; sym = sym->u.tnd_var.next)
  74.       ++ntend;
  75.    if (ntend == 0)
  76.       cur_impl->tnds = NULL;
  77.    else
  78.       cur_impl->tnds = (struct tend_var *)alloc((unsigned int)
  79.          (sizeof(struct tend_var) * ntend));
  80.    cur_impl->ntnds = ntend;
  81.    i = 0;
  82.  
  83.    /*
  84.     * Go back through the declarations and fill in the array for the 
  85.     *  tended part of the data base symbol table. Array entries contain
  86.     *  an indication of the type of tended declaration, the C code to
  87.     *  initialize the variable if there is any, and, for block pointer
  88.     *  declarations, the type of block. rtt's symbol table is updated to
  89.     *  contain the variable's offset into the data base's symbol table.
  90.     *  Note that paramters are considered part of the data base's symbol
  91.     *  table when computing the offset and il_indx initially contains
  92.     *  their number.
  93.     */
  94.    for (sym = dcl_stk->tended; sym != NULL; sym = sym->u.tnd_var.next) {
  95.       cur_impl->tnds[i].var_type = sym->id_type;
  96.       cur_impl->tnds[i].init = inlin_c(sym->u.tnd_var.init, 0);
  97.       cur_impl->tnds[i].blk_name = sym->u.tnd_var.blk_name;
  98.       sym->il_indx = il_indx++;
  99.       ++i;
  100.       }
  101.  
  102.    /*
  103.     * The data base's symbol table also has entries for non-tended
  104.     *  variables from the declare statement. Each entry has the
  105.     *  identifier for the variable and the declaration (redundantly
  106.     *  including the identifier). Once again the offset for the data
  107.     *  base symbol table is stored in rtt's symbol table.
  108.     */
  109.    nvars = -il_indx;  /* pre-subtract preceding number of entries */
  110.    for (sym = decl_lst; sym != NULL; sym = sym->u.declare_var.next)
  111.       sym->il_indx = il_indx++;
  112.    nvars += il_indx;  /* compute number of entries in this part of table */
  113.    cur_impl->nvars = nvars;
  114.    if (nvars > 0) {
  115.       cur_impl->vars = (struct ord_var *)alloc((unsigned int)
  116.          (sizeof(struct ord_var) * nvars));
  117.       i = 0;
  118.       for (sym = decl_lst; sym != NULL; sym = sym->u.declare_var.next) {
  119.          cur_impl->vars[i].name = sym->image;
  120.          cur_impl->vars[i].dcl = ilc_dcl(sym->u.declare_var.tqual,
  121.             sym->u.declare_var.dcltor, sym->u.declare_var.init);
  122.          ++i;
  123.          }
  124.       }
  125.  
  126.    abs_ret = NoAbstr;           /* abstract clause not encountered yet */
  127.    cur_impl->in_line = il_walk(n); /* produce in-line code for operation */
  128.    }
  129.  
  130. /*
  131.  * il_walk - walk the syntax tree producing in-line code.
  132.  */
  133. static struct il_code *il_walk(n)
  134. struct node *n;
  135.    {
  136.    struct token *t;
  137.    struct node *n1;
  138.    struct node *n2;
  139.    struct il_code *il;
  140.    struct il_code *il1;
  141.    struct sym_entry *sym;
  142.    struct init_tend *tnd;
  143.    int ntend;
  144.  
  145.    if (n == NULL)
  146.       return NULL;
  147.  
  148.    t =  n->tok;
  149.  
  150.    switch (n->nd_id) {
  151.       case PrefxNd:
  152.          switch (t->tok_id) {
  153.             case '{':
  154.                /*
  155.                 * RTL code: { <actions> }
  156.                 */
  157.                il = il_walk(n->u[0].child);
  158.                break;
  159.             case '!':
  160.                /*
  161.                 * RTL type-checking and conversions: ! <simple-type-check>
  162.                 */
  163.                il = new_il(IL_Bang, 1);
  164.                il->u[0].fld = il_walk(n->u[0].child);
  165.                break;
  166.             case Body:
  167.                /*
  168.                 * RTL code: body { <c-code> }
  169.                 */
  170.                il = body_fnc(n);
  171.                break;
  172.             case Inline:
  173.                /*
  174.                 * RTL code: inline { <c-code> }
  175.                 *
  176.                 *  An in-line code "block" in the data base starts off
  177.                 *  with a list of tended descriptors needed by the in-line
  178.                 *  C code. The list indicates the kind of tended descriptor.
  179.                 *  The list is determined by walking to the syntax tree
  180.                 *  for the C code; tend_lst points to its beginning.
  181.                 *  The last item in the block is the C code itself.
  182.                 */
  183.                free_tend();
  184.                lcl_tend(n);
  185.                if (tend_lst == NULL)
  186.                   ntend = 0;
  187.                else
  188.                   ntend = tend_lst->t_indx + 1;
  189.                il = new_il(IL_Block, 2 + ntend);
  190.                il->u[0].n = ntend;
  191.                for (tnd = tend_lst; tnd != NULL; tnd = tnd->next)
  192.                   il->u[1 + tnd->t_indx].n = tnd->init_typ;
  193.                il->u[ntend + 1].c_cd = inlin_c(n->u[0].child, 0);
  194.                break;
  195.             case Type:
  196.                /*
  197.                 * RTL abstract type computation: type( <variable> )
  198.                 */
  199.                il = new_il(IL_VarTyp, 1);
  200.                il->u[0].fld = il_var(n->u[0].child);
  201.                break; 
  202.             case Store:
  203.                /*
  204.                 * RTL abstract type computation: store[ <type> ]
  205.                 */
  206.                il = new_il(IL_Store, 1);
  207.                il->u[0].fld = il_walk(n->u[0].child);
  208.                break; 
  209.             }
  210.          break;
  211.       case PstfxNd:
  212.          /*
  213.           * RTL abstract type computation: <type> . <attrb_name>
  214.           *
  215.           *  Each kind of attribute is given a different code in the
  216.           *  data base.
  217.           */
  218.          switch (t->tok_id) {
  219.             case Lst_elem:
  220.                il = new_il(IL_LstElm, 1);
  221.                break; 
  222.             case Set_elem:
  223.                il = new_il(IL_SetElm, 1);
  224.                break; 
  225.             case Key:
  226.                il = new_il(IL_TblKey, 1);
  227.                break; 
  228.             case Tbl_elem:
  229.                il = new_il(IL_TblElm, 1);
  230.                break; 
  231.             case Default:
  232.                il = new_il(IL_TblDft, 1);
  233.                break; 
  234.             case All_fields:
  235.                il = new_il(IL_Fields, 1);
  236.                break; 
  237.             case Str_var:
  238.                il = new_il(IL_StrVar, 1);
  239.                break; 
  240.             case Trpd_tbl:
  241.                il = new_il(IL_TrpTbl, 1);
  242.                break; 
  243.             }
  244.             il->u[0].fld = il_walk(n->u[0].child);
  245.          break;
  246.       case IcnTypNd:
  247.          /*
  248.           * RTL abstract type computation: <icon-type>
  249.           */
  250.          il = new_il(IL_IcnTyp, 1);
  251.          il->u[0].n = icn_typ(n->u[0].child);
  252.          break;
  253.       case BinryNd:
  254.          switch (t->tok_id) {
  255.             case Runerr:
  256.                /*
  257.                 * RTL code: runerr( <message-number> )
  258.                 *           runerr( <message-number>, <descriptor> )
  259.                 */
  260.                if (n->u[1].child == NULL)
  261.                   il = new_il(IL_Err1, 1);
  262.                else {
  263.                   il = new_il(IL_Err2, 2);
  264.                   il->u[1].fld = il_var(n->u[1].child);
  265.                   }
  266.                il->u[0].n = atol(n->u[0].child->tok->image);
  267.                /*
  268.                 * Execution cannot continue on this execution path, so
  269.                 *  it contributes nothing to the location of parameters.
  270.                 */
  271.                for (sym = params; sym != NULL; sym = sym->u.param_info.next)
  272.                   if (sym->id_type & DrfPrm)
  273.                      sym->u.param_info.cur_loc = 0;
  274.                break;
  275.             case And:
  276.                /*
  277.                 * RTL type-checking and conversions:
  278.                 *   <type-check> && <type_check>
  279.                 */
  280.                il = new_il(IL_And, 2);
  281.                il->u[0].fld = il_walk(n->u[0].child);
  282.                il->u[1].fld = il_walk(n->u[1].child);
  283.                break;
  284.             case Is:
  285.                /*
  286.                 * RTL type-checking and conversions:
  287.                 *   is: <icon-type> ( <variable> )
  288.                 */
  289.                il = new_il(IL_Is, 2);
  290.                il->u[0].n = icn_typ(n->u[0].child);
  291.                il->u[1].fld = il_var(n->u[1].child);
  292.                break;
  293.             case '=':
  294.                /*
  295.                 * RTL abstract type computation: store[ <type> ] = <type>
  296.                 */
  297.                il = new_il(IL_TpAsgn, 2);
  298.                il->u[0].fld = il_walk(n->u[0].child);
  299.                il->u[1].fld = il_walk(n->u[1].child);
  300.                break;
  301.             case Incr: /* union */
  302.                /*
  303.                 * RTL abstract type computation: <type> ++ <type>
  304.                 */
  305.                il = new_il(IL_Union, 2);
  306.                il->u[0].fld = il_walk(n->u[0].child);
  307.                il->u[1].fld = il_walk(n->u[1].child);
  308.                break;
  309.             case Intersect:
  310.                /*
  311.                 * RTL abstract type computation: <type> ** <type>
  312.                 */
  313.                il = new_il(IL_Inter, 2);
  314.                il->u[0].fld = il_walk(n->u[0].child);
  315.                il->u[1].fld = il_walk(n->u[1].child);
  316.                break;
  317.             case New: {
  318.                /*
  319.                 * RTL abstract type computation:
  320.                 *   new <icon-type> ( <type> ,  ... )
  321.                 */
  322.                struct node *typ;
  323.                struct node *args;
  324.                int typ_cd;
  325.                int nargs;
  326.  
  327.                typ = n->u[0].child;
  328.                args = n->u[1].child;
  329.  
  330.                /*
  331.                 * Determine the number of arguments expected for this
  332.                 *  structure type.
  333.                 */
  334.                typ_cd = icn_typ(typ);
  335.                switch (typ_cd) {
  336.                   case TypList:
  337.                   case TypSet:
  338.                   case TypTvStr:
  339.                   case TypTvTbl:
  340.                      nargs = 1;
  341.                      break;
  342.                   case TypTbl:
  343.                      nargs = 3;
  344.                      break;
  345.                   default:
  346.                     errt2(typ->tok,typ->tok->image," is not a structure type.");
  347.                   }
  348.  
  349.                /*
  350.                 * Create the "new" construct for the data base with its type
  351.                 *  code and arguments.
  352.                 */
  353.                il = new_il(IL_New, 2 + nargs); 
  354.                il->u[0].n = typ_cd;
  355.                il->u[1].n = nargs;
  356.                while (nargs > 1) {
  357.                   if (args->nd_id == CommaNd)
  358.                      il->u[1 + nargs].fld = il_walk(args->u[1].child);
  359.                   else
  360.                      errt2(typ->tok, "too few arguments for new",
  361.                         typ->tok->image);
  362.                   args = args->u[0].child;
  363.                   --nargs;
  364.                   }
  365.                if (args->nd_id == CommaNd)
  366.                   errt2(typ->tok, "too many arguments for new",typ->tok->image);
  367.                il->u[2].fld = il_walk(args);
  368.                }
  369.                break;
  370.             }
  371.          break;
  372.       case ConCatNd:
  373.          /*
  374.           * "Glue" for two constructs.
  375.           */
  376.          il = new_il(IL_Lst, 2);
  377.          il->u[0].fld = il_walk(n->u[0].child);
  378.          il->u[1].fld = il_walk(n->u[1].child);
  379.          break;
  380.       case AbstrNd:
  381.          /*
  382.           * RTL code: abstract { <type-computations> }
  383.           *
  384.           *  Remember the return statement if there is one. It is used for
  385.           *  type checking when types are easily determined.
  386.           */
  387.          il = new_il(IL_Abstr, 2);
  388.          il->u[0].fld = il_walk(n->u[0].child);
  389.          il1 = il_walk(n->u[1].child);
  390.          il->u[1].fld = il1;
  391.          if (il1 != NULL) {
  392.             if (abs_ret != NoAbstr)
  393.                errt1(t,"only one abstract return may be on any execution path");
  394.             if (il1->il_type == IL_IcnTyp || il1->il_type == IL_New)
  395.                abs_ret = il1->u[0].n;
  396.             else
  397.                abs_ret = SomeType;
  398.             }
  399.          break;
  400.       case TrnryNd:
  401.          switch (t->tok_id) {
  402.             case If: {
  403.                /*
  404.                 * RTL code for "if" statements:
  405.                 *  if <type-check> then <action>
  406.                 *  if <type-check> then <action> else <action>
  407.                 *
  408.                 *  <type-check> may include parameter conversions that create
  409.                 *  new scoping. It is necessary to keep track of paramter
  410.                 *  types and locations along success and failure paths of
  411.                 *  these conversions. The "then" and "else" actions may
  412.                 *  also establish new scopes (if a parameter is used within
  413.                 *  a overlapping scopes that conflict, it has already been
  414.                 *  detected).
  415.                 *
  416.                 *  The "then" and "else" actions may contain abstract return
  417.                 *  statements. The types of these must be "merged" in case
  418.                 *  type checking must be done on real return or suspend
  419.                 *  statements following the "if".
  420.                 */
  421.                int *then_prms = NULL;
  422.                int *else_prms;
  423.                struct node *cond;
  424.                struct node *else_nd;
  425.                int sav_absret;
  426.                int new_absret;
  427.  
  428.                /*
  429.                 * Save the current parameter locations. These are in
  430.                 *  effect on the failure path of any type conversions
  431.                 *  in the condition of the "if". Also remember any
  432.                 *  information from astract returns.
  433.                 */
  434.                else_prms = new_prmloc();
  435.                sv_prmloc(else_prms);
  436.                sav_absret = new_absret = abs_ret;
  437.  
  438.                cond = n->u[0].child;
  439.                else_nd = n->u[2].child;
  440.  
  441.                if (else_nd == NULL)
  442.                   il = new_il(IL_If1, 2);
  443.                else
  444.                   il = new_il(IL_If2, 3);
  445.                il->u[0].fld = il_walk(cond);
  446.                /*
  447.                 * If the condition is negated, the failure path is to the "then"
  448.                 *  and the success path is to the "else".
  449.                 */
  450.                if (cond->nd_id == PrefxNd && cond->tok->tok_id == '!') {
  451.                   then_prms = else_prms;
  452.                   else_prms = new_prmloc();
  453.                   sv_prmloc(else_prms);
  454.                   ld_prmloc(then_prms);
  455.                   }
  456.                il->u[1].fld = il_walk(n->u[1].child);  /* then ... */
  457.                if (else_nd == NULL) {
  458.                   mrg_prmloc(else_prms);
  459.                   ld_prmloc(else_prms);
  460.                   }
  461.                else {
  462.                   if (then_prms == NULL)
  463.                      then_prms = new_prmloc();
  464.                   sv_prmloc(then_prms);
  465.                   ld_prmloc(else_prms);
  466.                   new_absret = mrg_abstr(new_absret, abs_ret);
  467.                   abs_ret = sav_absret;
  468.                   il->u[2].fld = il_walk(else_nd);
  469.                   mrg_prmloc(then_prms);
  470.                   ld_prmloc(then_prms);
  471.                   }
  472.                abs_ret = mrg_abstr(new_absret, abs_ret);
  473.                if (then_prms != NULL)
  474.                   free(then_prms);
  475.                if (else_prms != NULL)
  476.                   free(else_prms);
  477.                }
  478.                break;
  479.             case Len_case: {
  480.                /*
  481.                 * RTL code:
  482.                 *   len_case <variable> of {
  483.                 *      <integer>: <action>
  484.                 *        ...
  485.                 *      default: <action>
  486.                 *      }
  487.                 */
  488.                int *strt_prms;
  489.                int *end_prms;
  490.                int n_cases;
  491.                int indx;
  492.                int sav_absret;
  493.                int new_absret;
  494.  
  495.                /*
  496.                 * A case may contain parameter conversions that create new
  497.                 *  scopes. Remember the parameter locations at the start
  498.                 *  of the len_case statement. Also remember information
  499.                 *  about abstract type returns.
  500.                 */
  501.                strt_prms = new_prmloc();
  502.                sv_prmloc(strt_prms);
  503.                end_prms = new_prmloc();
  504.                sav_absret = new_absret = abs_ret;
  505.  
  506.                /*
  507.                 * Count the number of cases; there is at least one.
  508.                 */
  509.                n_cases = 1;
  510.                for (n1 = n->u[1].child; n1->nd_id == ConCatNd;
  511.                    n1 = n1->u[0].child)
  512.                       ++n_cases;
  513.  
  514.                /*
  515.                 * The data base entry has one slot for the number of cases,
  516.                 *  one for the default clause, and two for each case. A
  517.                 *  case includes a selection integer and an action.
  518.                 */
  519.                il = new_il(IL_Lcase, 2 + 2 * n_cases);
  520.                il->u[0].n = n_cases;
  521.  
  522.                /*
  523.                 * Go through the cases, adding them to the data base entry.
  524.                 *  Merge resulting parameter locations and information
  525.                 *  about abstract type returns, then restore the starting
  526.                 *  information for the next case.
  527.                 */
  528.                indx = 2 * n_cases;
  529.                for (n1 = n->u[1].child; n1->nd_id == ConCatNd;
  530.                     n1 = n1->u[0].child) {
  531.                   il->u[indx--].fld = il_walk(n1->u[1].child->u[0].child);
  532.                   il->u[indx--].n = atol(n1->u[1].child->tok->image);
  533.                   mrg_prmloc(end_prms);
  534.                   ld_prmloc(strt_prms);
  535.                   new_absret = mrg_abstr(new_absret, abs_ret);
  536.                   abs_ret = sav_absret;
  537.                   }
  538.                /*
  539.                 * Last case.
  540.                 */
  541.                il->u[indx--].fld = il_walk(n1->u[0].child);
  542.                il->u[indx].n = atol(n1->tok->image);
  543.                mrg_prmloc(end_prms);
  544.                ld_prmloc(strt_prms);
  545.                new_absret = mrg_abstr(new_absret, abs_ret);
  546.                abs_ret = sav_absret;
  547.                /*
  548.                 * Default clause.
  549.                 */
  550.                il->u[1 + 2 * n_cases].fld = il_walk(n->u[2].child);
  551.                mrg_prmloc(end_prms);
  552.                ld_prmloc(end_prms);
  553.                abs_ret = mrg_abstr(new_absret, abs_ret);
  554.                if (strt_prms != NULL)
  555.                   free(strt_prms);
  556.                if (end_prms != NULL)
  557.                   free(end_prms);
  558.                }
  559.                break;
  560.             case Type_case: {
  561.                /*
  562.                 * RTL code:
  563.                 *   type_case <variable> of {
  564.                 *       <icon_type> : ... <icon_type> : <action>
  565.                 *          ...
  566.                 *       }
  567.                 *
  568.                 *   last clause may be: default: <action>
  569.                 */
  570.                struct node *sel;
  571.                int *strt_prms;
  572.                int *end_prms;
  573.                int *typ_vect;
  574.                int n_case;
  575.                int n_typ;
  576.                int n_fld;
  577.                int sav_absret;
  578.                int new_absret;
  579.  
  580.                /*
  581.                 * A case may contain parameter conversions that create new
  582.                 *  scopes. Remember the parameter locations at the start
  583.                 *  of the type_case statement. Also remember information
  584.                 *  about abstract type returns.
  585.                 */
  586.                strt_prms = new_prmloc();
  587.                sv_prmloc(strt_prms);
  588.                end_prms = new_prmloc();
  589.                sav_absret = new_absret = abs_ret;
  590.  
  591.                /*
  592.                 * Count the number of cases.
  593.                 */
  594.                n_case = 0;
  595.                for (n1 = n->u[1].child; n1 != NULL; n1 = n1->u[0].child)
  596.                   ++n_case;
  597.  
  598.                /*
  599.                 * The data base entry has one slot for the variable whose
  600.                 *  type is being tested, one for the number cases, three
  601.                 *  for each case, and, if there is default clause, one
  602.                 *  for it. Each case includes the number of types selected
  603.                 *  by the case, a vectors of those types, and the action
  604.                 *  for the case.
  605.                 */
  606.                if (n->u[2].child == NULL) {
  607.                   il = new_il(IL_Tcase1, 3 * n_case + 2);
  608.                   il->u[0].fld = il_var(n->u[0].child);
  609.                   }
  610.                else {
  611.                   /*
  612.                    * There is a default clause.
  613.                    */
  614.                   il = new_il(IL_Tcase2, 3 * n_case + 3);
  615.                   il->u[0].fld = il_var(n->u[0].child);
  616.                   il->u[3 * n_case + 2].fld = il_walk(n->u[2].child);
  617.                   mrg_prmloc(end_prms);
  618.                   ld_prmloc(strt_prms);
  619.                   }
  620.                il->u[1].n = n_case;
  621.  
  622.                /*
  623.                 * Go through the cases, adding them to the data base entry.
  624.                 *  Merge resulting parameter locations and information
  625.                 *  about abstract type returns, then restore the starting
  626.                 *  information for the next case.
  627.                 */
  628.                n_fld = 2;
  629.                for (n1 = n->u[1].child; n1 != NULL; n1 = n1->u[0].child) {
  630.                   /*
  631.                    * Determine the number types selected by the case and
  632.                    *  put the types in a vector.
  633.                    */
  634.                   sel = n1->u[1].child;
  635.                   n_typ = 0;
  636.                   for (n2 = sel->u[0].child; n2 != NULL; n2 = n2->u[0].child)
  637.                      n_typ++;
  638.                   il->u[n_fld++].n = n_typ;
  639.                   typ_vect = (int *)alloc((unsigned int)(sizeof(int) * n_typ));
  640.                   il->u[n_fld++].vect = typ_vect;
  641.                   n_typ = 0;
  642.                   for (n2 = sel->u[0].child; n2 != NULL; n2 = n2->u[0].child)
  643.                      typ_vect[n_typ++] = icn_typ(n2->u[1].child);
  644.                   /*
  645.                    * Add code for the case to the data  base entry.
  646.                    */
  647.                   new_absret = mrg_abstr(new_absret, abs_ret);
  648.                   abs_ret = sav_absret;
  649.                   il->u[n_fld++].fld = il_walk(sel->u[1].child);
  650.                   mrg_prmloc(end_prms);
  651.                   ld_prmloc(strt_prms);
  652.                   }
  653.                ld_prmloc(end_prms);
  654.                abs_ret = mrg_abstr(new_absret, abs_ret);
  655.                if (strt_prms != NULL)
  656.                   free(strt_prms);
  657.                if (end_prms != NULL)
  658.                   free(end_prms);
  659.                }
  660.                break;
  661.             case Cnv: {
  662.                /*
  663.                 * RTL code: cnv: <type> ( <source> )
  664.                 *           cnv: <type> ( <source> , <destination> )
  665.                 */
  666.                struct node *typ;
  667.                struct node *src;
  668.                struct node *dst;
  669.  
  670.                typ = n->u[0].child;
  671.                src = n->u[1].child;
  672.                dst = n->u[2].child;
  673.                if (dst == NULL) {
  674.                   il = new_il(IL_Cnv1, 2);
  675.                   il->u[0].n = icn_typ(typ);
  676.                   il->u[1].fld = il_var(src);
  677.                   /*
  678.                    * This "in-place" conversion may create a new scope for the
  679.                    *  source parameter.
  680.                    */
  681.                   chng_ploc(typ, src);
  682.                   }
  683.                else {
  684.                   il = new_il(IL_Cnv2, 3);
  685.                   il->u[0].n = icn_typ(typ);
  686.                   il->u[1].fld = il_var(src);
  687.                   il->u[2].c_cd = inlin_c(dst, 1);
  688.                   }
  689.                }
  690.                break;
  691.             }
  692.          break;
  693.       case QuadNd: {
  694.          /*
  695.           * RTL code: def: <type> ( <source> , <default>)
  696.           *           def: <type> ( <source> , <default> , <destination> )
  697.           */
  698.          struct node *typ;
  699.          struct node *src;
  700.          struct node *dflt;
  701.          struct node *dst;
  702.  
  703.          typ = n->u[0].child;
  704.          src = n->u[1].child;
  705.          dflt = n->u[2].child;
  706.          dst = n->u[3].child;
  707.          if (dst == NULL) {
  708.             il = new_il(IL_Def1, 3);
  709.             il->u[0].n = icn_typ(typ);
  710.             il->u[1].fld = il_var(src);
  711.             il->u[2].c_cd = inlin_c(dflt, 0);
  712.             /*
  713.              * This "in-place" conversion may create a new scope for the
  714.              *  source parameter.
  715.              */
  716.             chng_ploc(typ, src);
  717.             }
  718.          else {
  719.             il = new_il(IL_Def2, 4);
  720.             il->u[0].n = icn_typ(typ);
  721.             il->u[1].fld = il_var(src);
  722.             il->u[2].c_cd = inlin_c(dflt, 0);
  723.             il->u[3].c_cd = inlin_c(dst, 1);
  724.             }
  725.          }
  726.          break;
  727.       }
  728.    return il;
  729.    }
  730.  
  731. /*
  732.  * il_var - produce in-line code in the data base for varibel references.
  733.  *   These include both simple identifiers and subscripted identifiers.
  734.  */
  735. static struct il_code *il_var(n)
  736. struct node *n;
  737.    {
  738.    struct il_code *il;
  739.  
  740.    if (n->nd_id == SymNd) {
  741.       il = new_il(IL_Var, 1);
  742.       il->u[0].n = n->u[0].sym->il_indx; /* offset into data base sym. tab. */
  743.       }
  744.    else if (n->nd_id == BinryNd) {
  745.       /*
  746.        * A subscripted variable.
  747.        */
  748.       il = new_il(IL_Subscr, 2);
  749.       il->u[0].n = n->u[0].child->u[0].sym->il_indx; /* sym. tab. offset */
  750.       il->u[1].n = atol(n->u[1].child->tok->image);  /* subscript */
  751.       }
  752.    else
  753.       errt2(n->tok, "undeclared identifier: ", n->tok->image);
  754.    return il;
  755.    }
  756.  
  757. /*
  758.  * icn_typ - convert a type node into a type code for the internal
  759.  *   representation of the data base.
  760.  */
  761. static int icn_typ(typ)
  762. struct node *typ;
  763.    {
  764.    if (typ->nd_id == PrimryNd)
  765.       switch (typ->tok->tok_id) {
  766.          case Empty_type:
  767.             return TypEmpty;
  768.          case Null:
  769.             return TypNull;
  770.          case String:
  771.             return TypStr;
  772.          case Cset:
  773.             return TypCset;
  774.          case Integer:
  775.             return TypInt;
  776.          case Real:
  777.             return TypReal;
  778.          case File:
  779.             return TypFile;
  780.          case List:
  781.             return TypList;
  782.          case Set:
  783.             return TypSet;
  784.          case Table:
  785.             return TypTbl;
  786.          case Record:
  787.             return TypRec;
  788.          case Procedure:
  789.             return TypProc;
  790.          case Co_expression:
  791.             return TypCoExp;
  792.          case Variable:
  793.             return TypVar;
  794.          case Tvsubs:
  795.             return TypTvStr;
  796.          case Tvtbl:
  797.             return TypTvTbl;
  798.          case Kywdint:
  799.             return TypKyInt;
  800.          case Kywdpos:
  801.             return TypKyPos;
  802.          case Kywdsubj:
  803.             return TypKySub;
  804.          case C_Integer:
  805.             return TypCInt;
  806.          case C_Double:
  807.             return TypCDbl;
  808.          case C_String:
  809.             return TypCStr;
  810.          case Tmp_string:
  811.             return TypTStr;
  812.          case Tmp_cset:
  813.             return TypTCset;
  814.          }
  815.    else {   /* must be exact conversion */
  816.       if (typ->tok->tok_id == Integer)
  817.          return TypEInt;
  818.       else     /* C_Integer */
  819.          return TypECInt;
  820.       }
  821.    err1("rtt internal error detected in function icn_typ()");
  822.    /* NOTREACHED */
  823.    }
  824.  
  825.  
  826. /*
  827.  * body_anlz - walk the syntax tree for the C code in a body statment,
  828.  *  analyzing the code to determine the iterface needed by the C function 
  829.  *  which will implement it. Also determine how many buffers are needed.
  830.  *  The value returned inticates whether it is possible for execution
  831.  *  to fall through the the code; knowing when execution does not fall
  832.  *  through helps produce better code.
  833.  */
  834. static int body_anlz(n, does_break, may_mod)
  835. struct node *n;   /* subtree being analyzed */
  836. int *does_break;  /* output flag: subtree contains "break;" */
  837. int may_mod;      /* input flag: this subtree might be assigned to */
  838.    {
  839.    struct token *t;
  840.    struct sym_entry *sym;
  841.    struct var_lst *var_ref;
  842.    int break_chk = 0;
  843.  
  844.    if (n == NULL)
  845.       return 1; 
  846.  
  847.    t =  n->tok;
  848.  
  849.    switch (n->nd_id) {
  850.       case PrimryNd:
  851.          switch (t->tok_id) {
  852.             case Fail:
  853.                ret_flag |= DoesFail;
  854.                return 0;
  855.             case Errorfail:
  856.                ret_flag |= DoesEFail;
  857.                return 0;
  858.             case Break:
  859.                *does_break = 1;
  860.                return 1;
  861.             default: /* do nothing special */
  862.                return 1;
  863.             }
  864.       case PrefxNd:
  865.          switch (t->tok_id) {
  866.             case Return:
  867.                ret_flag |= DoesRet;
  868.                chkrettyp(n->u[0].child); /* check for returning of C value */
  869.                body_anlz(n->u[0].child, does_break, 0);
  870.                return 0;
  871.             case Suspend:
  872.                ret_flag |= DoesSusp;
  873.                chkrettyp(n->u[0].child); /* check for returning of C value */
  874.                body_anlz(n->u[0].child, does_break, 0);
  875.                return 1;
  876.             case '(':
  877.                /*
  878.                 * parenthesized expression: pass along may_mod.
  879.                 */
  880.                return body_anlz(n->u[0].child, does_break, may_mod);
  881.             case Incr: /* ++ */
  882.             case Decr: /* -- */
  883.             case '&':
  884.                /*
  885.                 * Operand may be modified. Note that inclusion of the
  886.                 *  "address of" operator insures conservative results
  887.                 *  as we don't know how the address will be used.
  888.                 */
  889.                body_anlz(n->u[0].child, does_break, 1);
  890.                return 1;
  891.             case Goto:
  892.                body_anlz(n->u[0].child, does_break, 0);
  893.                return 0;
  894.             default: /* unary operations the need nothing special */
  895.                body_anlz(n->u[0].child, does_break, 0);
  896.                return 1;
  897.             }
  898.       case PstfxNd:
  899.          if (t->tok_id == ';')
  900.             body_anlz(n->u[0].child, does_break, 0);
  901.          else {
  902.             /*
  903.              * C expressions: <expr> ++
  904.              *                <expr> --
  905.              *
  906.              * modify operand
  907.              */
  908.             body_anlz(n->u[0].child, does_break, 1);
  909.             }
  910.          return 1;
  911.       case PreSpcNd:
  912.          body_anlz(n->u[0].child, does_break, 0);
  913.          return 1;
  914.       case SymNd:
  915.          /*
  916.           * This is an identifier.
  917.           */
  918.          sym = n->u[0].sym;
  919.          if (sym->id_type == RsltLoc) {
  920.             /*
  921.              * Note that this body code explicitly references the result
  922.              *  location of the operation.
  923.              */
  924.             rslt_loc = 1;
  925.             }
  926.          else if (sym->nest_lvl == 2) {
  927.             /*
  928.              * This variable is local to the operation, but declared outside
  929.              *  the body. It must passed as a parameter to the function.
  930.              *  See if it is in the parameter list yet.
  931.              */
  932.             if (!(sym->id_type & PrmMark)) {
  933.                sym->id_type |= PrmMark;
  934.                if ((var_ref = v_lst_free) == NULL)
  935.                   var_ref = NewStruct(var_lst);
  936.                else
  937.                   v_lst_free = v_lst_free->next;
  938.                var_ref->sym = sym;
  939.                var_ref->next = body_prms;
  940.                body_prms = var_ref;
  941.                ++n_bdy_prms;
  942.                }
  943.  
  944.             /*
  945.              *  Note if the variable might be assigned to.
  946.              */
  947.             sym->may_mod |= may_mod;
  948.             }
  949.          return 1;
  950.       case BinryNd:
  951.          switch (t->tok_id) {
  952.             case '[': /* subscripting */
  953.             case '.':
  954.                /*
  955.                 * Assignments will modify left operand.
  956.                 */
  957.                body_anlz(n->u[0].child, does_break, may_mod);
  958.                body_anlz(n->u[1].child, does_break, 0);
  959.                return 1;
  960.             case Switch:
  961.                /*
  962.                 * "break;" statements in body of switch statment do
  963.                 *   not effect outer loops so pass along a new flag
  964.                 *   for does_break.
  965.                 */
  966.                body_anlz(n->u[0].child, does_break, 0);
  967.                body_anlz(n->u[1].child, &break_chk, 0);
  968.                return 1;
  969.             case While: {
  970.            struct node *n0 = n->u[0].child;
  971.                body_anlz(n0, does_break, 0);
  972.                body_anlz(n->u[1].child, &break_chk, 0);
  973.            /*
  974.         * check for an infinite loop, while (1) ... :
  975.                 *  a condition consisting of an IntConst with image=="1"
  976.                 *  and no breaks in the body.
  977.         */
  978.            if (n0->nd_id == PrimryNd && n0->tok->tok_id == IntConst &&
  979.            !strcmp(n0->tok->image,"1") && !break_chk)
  980.           return 0;
  981.                return 1;
  982.            }
  983.             case Do:
  984.                /*
  985.                 * Any "break;" statements in the body do not effect
  986.                 *  outer loops so pass along a new flag for does_break.
  987.                 */
  988.                body_anlz(n->u[0].child, &break_chk, 0);
  989.                body_anlz(n->u[1].child, does_break, 0);
  990.                return 1;
  991.             case Runerr:
  992.                body_anlz(n->u[0].child, does_break, 0);
  993.                body_anlz(n->u[1].child, does_break, 0);
  994.                ret_flag |= DoesEFail;  /* possibler error failure */
  995.                return 0;
  996.             case '=':
  997.             case MultAsgn:  /*  *=  */
  998.             case DivAsgn:   /*  /=  */
  999.             case ModAsgn:   /*  %=  */
  1000.             case PlusAsgn:  /*  +=  */
  1001.             case MinusAsgn: /*  -=  */
  1002.             case LShftAsgn: /* <<=  */
  1003.             case RShftAsgn: /* >>=  */
  1004.             case AndAsgn:   /*  &=  */
  1005.             case XorAsgn:   /*  ^=  */
  1006.             case OrAsgn:    /*  |=  */
  1007.                /*
  1008.                 * Left operand is modified.
  1009.                 */
  1010.                body_anlz(n->u[0].child, does_break, 1);
  1011.                body_anlz(n->u[1].child, does_break, 0);
  1012.                return 1;
  1013.             default: /* binary operations that need nothing special */
  1014.                body_anlz(n->u[0].child, does_break, 0);
  1015.                body_anlz(n->u[1].child, does_break, 0);
  1016.                return 1;
  1017.             }
  1018.       case LstNd:
  1019.       case ConCatNd:
  1020.       case CommaNd:
  1021.       case StrDclNd:
  1022.          /*
  1023.           * Binary nodes that need nothing special here. For some, whether
  1024.           *  execution falls through depends on the second operand.
  1025.           */
  1026.          body_anlz(n->u[0].child, does_break, 0);
  1027.          return body_anlz(n->u[1].child, does_break, 0);
  1028.       case CompNd:
  1029.          /*
  1030.           * Compound statement, look only at executable code.
  1031.           */
  1032.          return body_anlz(n->u[2].child, does_break, 0);
  1033.       case TrnryNd:
  1034.          switch (t->tok_id) {
  1035.             case Cnv:
  1036.                /*
  1037.                 * extended C code: cnv: <type> ( <source> )
  1038.                 *                  cnv: <type> ( <source> , <destination> )
  1039.                 *
  1040.                 *  For some conversions, buffers may have to be allocated.
  1041.                 *  An explicit destination must be marked as modified.
  1042.                 */
  1043.                cnt_bufs(n->u[0].child);
  1044.                body_anlz(n->u[1].child, does_break, 0);
  1045.                body_anlz(n->u[2].child, does_break, 1);
  1046.                return 1;
  1047.             case If:
  1048.                /*
  1049.                 * Execution falls through an if statement if it falls
  1050.                 *  through either branch. A null "else" branch always
  1051.                 *  falls through.
  1052.                 */
  1053.                body_anlz(n->u[0].child, does_break, 0);
  1054.                return body_anlz(n->u[1].child, does_break, 0) |
  1055.                   body_anlz(n->u[2].child, does_break, 0);
  1056.             default: /* nothing special is needed for these ternary nodes */
  1057.                body_anlz(n->u[0].child, does_break, 0);
  1058.                body_anlz(n->u[1].child, does_break, 0);
  1059.                body_anlz(n->u[2].child, does_break, 0);
  1060.                return 1;
  1061.                }
  1062.       case QuadNd:
  1063.          if (t->tok_id == Def) {
  1064.                /*
  1065.                 * extended C code:
  1066.                 *   def: <type> ( <source> , <default> )
  1067.                 *   def: <type> ( <source> , <default> , <destination> )
  1068.                 *
  1069.                 *  For some conversions, buffers may have to be allocated.
  1070.                 *  An explicit destination must be marked as modified.
  1071.                 */
  1072.                cnt_bufs(n->u[0].child);
  1073.                body_anlz(n->u[1].child, does_break, 0);
  1074.                body_anlz(n->u[2].child, does_break, 0);
  1075.                body_anlz(n->u[3].child, does_break, 1);
  1076.                return 1;
  1077.                }
  1078.           else {  /* for */
  1079.                /*
  1080.                 * Check for an infinite loop:  for (<expr>; ; <expr> ) ...
  1081.                 *
  1082.                 *  No ending condition and no breaks in the body.
  1083.                 */
  1084.                body_anlz(n->u[0].child, does_break, 0);
  1085.                body_anlz(n->u[1].child, does_break, 0);
  1086.                body_anlz(n->u[2].child, does_break, 0);
  1087.                body_anlz(n->u[3].child, &break_chk, 0);
  1088.                if (n->u[1].child == NULL && !break_chk)
  1089.                   return 0;
  1090.                else
  1091.                   return 1;
  1092.                }
  1093.       }
  1094.    err1("rtt internal error detected in function body_anlz()");
  1095.    /* NOTREACHED */
  1096.    }
  1097.  
  1098. /*
  1099.  *  lcl_tend  - allocate any tended variables needed in this body or inline
  1100.  *   statement.
  1101.  */
  1102. static novalue lcl_tend(n)
  1103. struct node *n;
  1104.    {
  1105.    struct sym_entry *sym;
  1106.  
  1107.    if (n == NULL)
  1108.       return; 
  1109.  
  1110.    /*
  1111.     * Walk the syntax tree until a block with declarations is found.
  1112.     */
  1113.    switch (n->nd_id) {
  1114.       case PrefxNd:
  1115.       case PstfxNd:
  1116.       case PreSpcNd:
  1117.         lcl_tend(n->u[0].child);
  1118.         break;
  1119.       case BinryNd:
  1120.       case LstNd:
  1121.       case ConCatNd:
  1122.       case CommaNd:
  1123.       case StrDclNd:
  1124.         lcl_tend(n->u[0].child);
  1125.         lcl_tend(n->u[1].child);
  1126.         break;
  1127.       case CompNd:
  1128.          /*
  1129.           * Allocate the tended variables in this block, noting that the
  1130.           *  level of nesting in this C funciton is one less than in the
  1131.           *  operation as a whole. Then mark the tended slots as free for
  1132.           *  use in the next block.
  1133.           */
  1134.          for (sym = n->u[1].sym; sym != NULL; sym = sym->u.tnd_var.next) {
  1135.             sym->t_indx = alloc_tnd(sym->id_type, sym->u.tnd_var.init,
  1136.                sym->nest_lvl - 1);
  1137.             }
  1138.          lcl_tend(n->u[2].child);
  1139.          sym = n->u[1].sym;
  1140.          if (sym != NULL)
  1141.             unuse(tend_lst, sym->nest_lvl - 1);
  1142.          break;
  1143.       case TrnryNd:
  1144.          lcl_tend(n->u[0].child);
  1145.          lcl_tend(n->u[1].child);
  1146.          lcl_tend(n->u[2].child);
  1147.          break;
  1148.       case QuadNd:
  1149.          lcl_tend(n->u[0].child);
  1150.          lcl_tend(n->u[1].child);
  1151.          lcl_tend(n->u[2].child);
  1152.          lcl_tend(n->u[3].child);
  1153.          break;
  1154.       }
  1155.    }
  1156.  
  1157. /*
  1158.  * chkrettyp - check type of return to see if it is a C integer or a
  1159.  *  C double and make note of what is found.
  1160.  */
  1161. static novalue chkrettyp(n)
  1162. struct node *n;
  1163.    {
  1164.    if (n->nd_id == PrefxNd && n->tok != NULL) {
  1165.       switch (n->tok->tok_id) {
  1166.          case C_Integer:
  1167.             body_ret |= RetInt;
  1168.             return;
  1169.          case C_Double:
  1170.             body_ret |= RetDbl;
  1171.             return;
  1172.          }
  1173.       }
  1174.    body_ret |= RetOther;
  1175.    }
  1176.  
  1177. /*
  1178.  * body_fnc - produce the function which implements a body statement.
  1179.  */
  1180. static struct il_code *body_fnc(n)
  1181. struct node *n;
  1182.    {
  1183.    struct node *compound;
  1184.    struct node *dcls;
  1185.    struct node *stmts;
  1186.    struct var_lst *var_ref;
  1187.    struct sym_entry *sym;
  1188.    struct il_code *il;
  1189.    int fall_thru;          /* flag: control can fall through end of body */
  1190.    int num_sigs;           /* number of different signals function may return */
  1191.    int bprm_indx;
  1192.    int first;
  1193.    int is_reg;
  1194.    int strct;
  1195.    int addr;
  1196.    int by_ref;
  1197.    int just_desc;
  1198.    int dummy_int;
  1199.    char buf1[6];
  1200.    char buf[MaxFileName];
  1201.    char *cname;
  1202.  
  1203.    /*
  1204.     * Figure out the next character to use as the 3rd prefix for the
  1205.     *  name of this body function.
  1206.     */
  1207.    if (prfx3 == ' ')
  1208.       prfx3 = '0';
  1209.    else if (prfx3 == '9')
  1210.       prfx3 = 'a';
  1211.    else if (prfx3 == 'z')
  1212.       errt2(n->tok, "more than 26 body statements in", cur_impl->name);
  1213.    else
  1214.       ++prfx3;
  1215.  
  1216.    /*
  1217.     * Free any old body parameters and tended locations.
  1218.     */
  1219.    while (body_prms != NULL) {
  1220.       var_ref = body_prms;
  1221.       body_prms = body_prms->next;
  1222.       var_ref->next = v_lst_free;
  1223.       v_lst_free = var_ref;
  1224.       }
  1225.    free_tend();
  1226.  
  1227.    /*
  1228.     * Locate the outer declarations and statements from the body clause.
  1229.     */
  1230.    compound = n->u[0].child;
  1231.    dcls = compound->u[0].child;
  1232.    stmts = compound->u[2].child;
  1233.  
  1234.    /*
  1235.     * Analyze the body code to determine what the function's interface
  1236.     *  needs. body_anlz() does the work after the counters and flags
  1237.     *  are initialized.
  1238.     /*
  1239.    n_tmp_str = 0;  /* number of tempory string buffers neeeded */
  1240.    n_tmp_cset = 0; /* number of tempory cset buffers needed */
  1241.    nxt_sbuf = 0;   /* next string buffer index; used in code generation */
  1242.    nxt_cbuf = 0;   /* next cset buffer index; used in code generation */
  1243.    n_bdy_prms = 0; /* number of variables needed as body function parameters */
  1244.    body_ret = 0;   /* flag: C values and/or non-C values returned */
  1245.    ret_flag = 0;   /* flag: return, suspend, fail, error fail */
  1246.    rslt_loc = 0;   /* flag: body code needs operations result location */
  1247.    fall_thru = body_anlz(compound, &dummy_int, 0);
  1248.    lcl_tend(n);    /* allocate tended descriptors needed */
  1249.  
  1250.  
  1251.    /*
  1252.     * Use the letter indicating operation type along with body function
  1253.     *  prefixes to construct the name of the file to hold the C code.
  1254.     */
  1255.    sprintf(buf1, "%c_%c%c%c", lc_letter, prfx1, prfx2, prfx3);
  1256.    cname = salloc(makename(buf, SourceDir, buf1, CSuffix));
  1257.    if ((out_file = fopen(cname, "w")) == NULL)
  1258.       err2("cannot open output file", cname);
  1259.       
  1260.    prologue(); /* output standard comments and preprocessor directives */
  1261.  
  1262.    /*
  1263.     * If the function produces a unique signal, the function need not actually
  1264.     *  return it, and we may be able to use the return value for something
  1265.     *  else. See if this is true.
  1266.     */
  1267.    num_sigs = 0;
  1268.    if (ret_flag & DoesRet)
  1269.       ++num_sigs;
  1270.    if (ret_flag & (DoesFail  | DoesEFail))
  1271.       ++num_sigs;
  1272.    if (ret_flag & DoesSusp)
  1273.       num_sigs += 2;    /* something > 1 (success cont. may return anything) */
  1274.    if (fall_thru) {
  1275.       ret_flag |= DoesFThru;
  1276.       ++num_sigs;
  1277.       }
  1278.  
  1279.    if (num_sigs > 1)
  1280.       fnc_ret = RetSig;  /* Function must return a signal */
  1281.    else {
  1282.       /*
  1283.        * If the body returns a C_integer or a C_double, we can make the
  1284.        *  function directly return the C value and the compiler can decide
  1285.        *  whether to construct a descriptor.
  1286.        */
  1287.       if (body_ret == RetInt || body_ret == RetDbl)
  1288.          fnc_ret = body_ret;
  1289.       else
  1290.          fnc_ret = RetNoVal; /* Function returns nothing directly */
  1291.       }
  1292.  
  1293.    /*
  1294.     * Decide whether the function needs to to be passed an explicit result
  1295.     *  location (the case where "result" is explicitly referenced is handled
  1296.     *  while analyzing the body). suspend always uses the result location.
  1297.     *  return uses the result location unless the function directly
  1298.     *  returns a C value.
  1299.     */
  1300.    if (ret_flag & DoesSusp)
  1301.       rslt_loc = 1;
  1302.    else if ((ret_flag & DoesRet) && (fnc_ret != RetInt && fnc_ret != RetDbl))
  1303.       rslt_loc = 1;
  1304.  
  1305.    /*
  1306.     * The data base entry for the call to the body function has 8 slots
  1307.     *  for standard interface information and 2 slots for each parameter.
  1308.     */
  1309.    il = new_il(IL_Call, 8 + 2 * n_bdy_prms);
  1310.    il->u[0].n = 0;         /* reserved for interanl use by compiler */
  1311.    il->u[1].n = prfx3;
  1312.    il->u[2].n = fnc_ret;
  1313.    il->u[3].n = ret_flag;
  1314.    il->u[4].n = rslt_loc;
  1315.    il->u[5].n = 0;       /* number of string buffers to pass in: set below */
  1316.    il->u[6].n = 0;       /* number of cset buffers to pass in: set below */
  1317.    il->u[7].n = n_bdy_prms;
  1318.    bprm_indx = 8;
  1319.  
  1320.    /*
  1321.     * Write the C function header for the body function.
  1322.     */
  1323.    switch (fnc_ret) {
  1324.       case RetSig:
  1325.          fprintf(out_file, "int ");
  1326.          break;
  1327.       case RetInt:
  1328.          fprintf(out_file, "C_integer ");
  1329.          break;
  1330.       case RetDbl:
  1331.          fprintf(out_file, "double ");
  1332.          break;
  1333.       case RetNoVal:
  1334.          fprintf(out_file, "novalue ");
  1335.          break;
  1336.       }
  1337.    fprintf(out_file, " %c%c%c%c_%s(", uc_letter, prfx1, prfx2, prfx3,
  1338.         cur_impl->name);
  1339.    fname = cname;
  1340.    line = 7;
  1341.  
  1342.    /*
  1343.     * Write parameter list, first the paranthesized list of names. Start
  1344.     *  with names of RLT variables that must be passed in.
  1345.     */
  1346.    first = 1;
  1347.    for (var_ref = body_prms; var_ref != NULL; var_ref = var_ref->next) {
  1348.       sym = var_ref->sym;
  1349.       sym->id_type &= ~PrmMark;             /* unmark entry */
  1350.       if (first)
  1351.          first = 0;
  1352.       else
  1353.          prt_str(", ", IndentInc);
  1354.       prt_str(sym->image, IndentInc);
  1355.       }
  1356.  
  1357.    if (fall_thru) {
  1358.       /*
  1359.        * We cannot allocate string and cset buffers locally, so any
  1360.        *   that are needed must be parameters.
  1361.        */
  1362.       if (n_tmp_str > 0) {
  1363.          if (first)
  1364.             first = 0;
  1365.          else
  1366.             prt_str(", ", IndentInc);
  1367.          prt_str("r_sbuf", IndentInc);
  1368.          }
  1369.       if (n_tmp_cset > 0) {
  1370.          if (first)
  1371.             first = 0;
  1372.          else
  1373.             prt_str(", ", IndentInc);
  1374.          prt_str("r_cbuf", IndentInc);
  1375.          }
  1376.       }
  1377.  
  1378.    /*
  1379.     * If the result location is needed it is passed as the next parameter.
  1380.     */
  1381.    if (rslt_loc) {
  1382.       if (first)
  1383.          first = 0;
  1384.       else
  1385.          prt_str(", ", IndentInc);
  1386.       prt_str("r_rslt", IndentInc);
  1387.       }
  1388.  
  1389.    /*
  1390.     * If a success continuation is needed, it goes last.
  1391.     */
  1392.    if (ret_flag & DoesSusp) {
  1393.       if (!first)
  1394.          prt_str(", ", IndentInc);
  1395.       prt_str("r_s_cont", IndentInc);
  1396.       }
  1397.    prt_str(")", IndentInc);
  1398.    ForceNl();
  1399.  
  1400.    /*
  1401.     * Go through the parameters to this function writing out declarations
  1402.     *  and filling in rest of data base entry. Start with RLT variables.
  1403.     */
  1404.    for (var_ref = body_prms; var_ref != NULL; var_ref = var_ref->next) {
  1405.       /*
  1406.        * Each parameters has two slots in the data base entry. One
  1407.        *  is the declaration for use by iconc in producing function
  1408.        *  prototypes. The other is the argument that must be passed as
  1409.        *  part of the call generated by iconc.
  1410.        *
  1411.        * Determine whether the parameter is passed by reference or by
  1412.        *  value (flag by_ref). Tended variables that refer to just the
  1413.        *  vword of a descriptor require special handling. They must
  1414.        *  be passed to the body function as a pointer to the entire
  1415.        *  decriptor and not just the vword. Within the function the
  1416.        *  parameter is then accessed as x->vword... This is indicated
  1417.        *  by the paramter flag just_desc.
  1418.        */
  1419.       sym = var_ref->sym;
  1420.       var_ref->id_type = sym->id_type;      /* save old id_type */
  1421.       by_ref = 0;
  1422.       just_desc = 0;
  1423.       switch (sym->id_type) {
  1424.          case TndDesc:  /* tended struct descrip x */
  1425.             by_ref = 1;
  1426.             il->u[bprm_indx++].c_cd = simpl_dcl("dptr ", 0, sym);
  1427.             break;
  1428.          case TndStr:   /* tended char *x */
  1429.          case TndBlk:   /* tended struct b_??? *x or tended union block *x */
  1430.             by_ref = 1;
  1431.             just_desc = 1;
  1432.             il->u[bprm_indx++].c_cd = simpl_dcl("dptr ", 0, sym);
  1433.             break;
  1434.          case RtParm: /* undereferenced RTL parameter */
  1435.          case DrfPrm: /* dereferenced RTL parameter */
  1436.             switch (sym->u.param_info.cur_loc) {
  1437.                case PrmTend: /* plain parameter: descriptor */
  1438.                   by_ref = 1;
  1439.                   il->u[bprm_indx++].c_cd = simpl_dcl("dptr ", 0, sym);
  1440.                   break;
  1441.                case PrmCStr: /* parameter converted to a tended C string */
  1442.                   by_ref = 1;
  1443.                   just_desc = 1;
  1444.                   il->u[bprm_indx++].c_cd = simpl_dcl("dptr ", 0, sym);
  1445.                   break;
  1446.                case PrmInt:  /* parameter converted to a C integer */
  1447.                   sym->id_type = OtherDcl;
  1448.                   if (var_ref->sym->may_mod && fall_thru)
  1449.                      by_ref = 1;
  1450.                   il->u[bprm_indx++].c_cd = simpl_dcl("C_integer ", by_ref,
  1451.                      sym);
  1452.                   break;
  1453.                case PrmDbl: /* parameter converted to a C double */
  1454.                   sym->id_type = OtherDcl;
  1455.                   if (var_ref->sym->may_mod && fall_thru)
  1456.                      by_ref =  1;
  1457.                   il->u[bprm_indx++].c_cd = simpl_dcl("double ", by_ref, sym);
  1458.                   break;
  1459.                }
  1460.             break;
  1461.          case RtParm | VarPrm:
  1462.          case DrfPrm | VarPrm:
  1463.             /*
  1464.              * Variable part of RTL parameter list: already descriptor pointer.
  1465.              */
  1466.             sym->id_type = OtherDcl;
  1467.             il->u[bprm_indx++].c_cd = simpl_dcl("dptr ", 0, sym);
  1468.             break;
  1469.          case VArgLen:
  1470.             /*
  1471.              * Number of elements in variable part of RTL paramter list:
  1472.              *  integer but not a true variable.
  1473.              */
  1474.             sym->id_type = OtherDcl;
  1475.             il->u[bprm_indx++].c_cd = simpl_dcl("int ", 0, sym);
  1476.             break;
  1477.          case OtherDcl:
  1478.             is_reg = 0;
  1479.             /*
  1480.              * Pass by reference if it is a structure or union type (but
  1481.              *  not if it is a pointer to one) or if the variable is
  1482.              *  modified and it is possible to execute more code after the
  1483.              *  body. WARNING: crude assumptions are made for typedef
  1484.              *  types.
  1485.              */
  1486.             strct = strct_typ(sym->u.declare_var.tqual, &is_reg);
  1487.             addr = is_addr(sym->u.declare_var.dcltor, '\0');
  1488.             if ((strct && !addr) || (var_ref->sym->may_mod && fall_thru))
  1489.                   by_ref = 1;
  1490.             if (is_reg && by_ref)
  1491.               errt2(sym->u.declare_var.dcltor->u[1].child->tok, sym->image,
  1492.                  " may not be declared 'register'");
  1493.  
  1494.             il->u[bprm_indx++].c_cd = parm_dcl(by_ref, sym);
  1495.             break;
  1496.          }
  1497.  
  1498.       /*
  1499.        * Determine what the iconc generated argument in a function
  1500.        *  call should look like.
  1501.        */
  1502.       il->u[bprm_indx++].c_cd = bdy_prm(by_ref, just_desc, sym,
  1503.          var_ref->sym->may_mod);
  1504.  
  1505.       /*
  1506.        * If it a call-by-reference parameter, indicate that the level
  1507.        *  of indirection must be taken into account within the function
  1508.        *  body.
  1509.        */
  1510.       if (by_ref)
  1511.          sym->id_type |= ByRef;
  1512.       }
  1513.    
  1514.    if (fall_thru) {
  1515.       /*
  1516.        * Write declarations for any needed buffer parameters.
  1517.        */
  1518.       if (n_tmp_str > 0) {
  1519.          prt_str("char (*r_sbuf)[MaxCvtLen];", 0);
  1520.          ForceNl();
  1521.          }
  1522.       if (n_tmp_cset > 0) {
  1523.          prt_str("struct b_cset *r_cbuf;", 0);
  1524.          ForceNl();
  1525.          }
  1526.       /*
  1527.        * Indicate that buffers must be allocated by compiler and not
  1528.        *  within the function.
  1529.        */
  1530.       il->u[5].n = n_tmp_str;
  1531.       il->u[6].n = n_tmp_cset;
  1532.       n_tmp_str = 0;
  1533.       n_tmp_cset = 0;
  1534.       }
  1535.  
  1536.    /*
  1537.     * Write declarations for result location and success continutation
  1538.     *  parameters if they are needed.
  1539.     */
  1540.    if (rslt_loc) {
  1541.       prt_str("dptr r_rslt;", 0);
  1542.       ForceNl();
  1543.       }
  1544.    if (ret_flag & DoesSusp) {
  1545.       prt_str("continuation r_s_cont;", 0);
  1546.       ForceNl();
  1547.       }
  1548.  
  1549.    /*
  1550.     * Output the code for the function including ordinary declaration,
  1551.     *  special declarations, and executable code.
  1552.     */
  1553.    prt_str("{", IndentInc);
  1554.    ForceNl();
  1555.    c_walk(dcls, IndentInc, 0);
  1556.    spcl_dcls(NULL);
  1557.    c_walk(stmts, IndentInc, 0);
  1558.    ForceNl();
  1559.    /*
  1560.     * If it is possible for excution to fall through to the end of
  1561.     *  the body function, and it does so, return an A_FallThru signal.
  1562.     */
  1563.    if (fnc_ret == RetSig && fall_thru) {
  1564.       prt_str("return A_FallThru;", IndentInc);
  1565.       ForceNl();
  1566.       }
  1567.    prt_str("}\n", IndentInc);
  1568.    fclose(out_file);
  1569.    put_c_fl(cname, 1);
  1570.  
  1571.    /*
  1572.     * Restore the symbol table to its previous state.
  1573.     */
  1574.    for (var_ref = body_prms; var_ref != NULL; var_ref = var_ref->next) {
  1575.       var_ref->sym->id_type = var_ref->id_type;
  1576.       var_ref->sym->may_mod = 0;
  1577.       }
  1578.  
  1579.    return il;
  1580.    }
  1581.  
  1582. /*
  1583.  * strct_typ - determine if the declaration may be for a structured type
  1584.  *   and look for register declarations.
  1585.  */
  1586. static int strct_typ(typ, is_reg)
  1587. struct node *typ;
  1588. int *is_reg;
  1589.    {
  1590.    if (typ->nd_id == LstNd) {
  1591.       return strct_typ(typ->u[0].child, is_reg) |
  1592.          strct_typ(typ->u[1].child, is_reg);
  1593.       }
  1594.    else if (typ->nd_id == PrimryNd) {
  1595.       switch (typ->tok->tok_id) {
  1596.          case Typedef:
  1597.          case Extern:
  1598.             errt2(typ->tok, "declare {...} should not contain ",
  1599.                typ->tok->image);
  1600.          case Register:
  1601.             *is_reg = 1;
  1602.             return 0;
  1603.          case TypeDefName:
  1604.             if (strcmp(typ->tok->image, "word")  == 0 ||
  1605.                 strcmp(typ->tok->image, "uword") == 0 ||
  1606.                 strcmp(typ->tok->image, "dptr")  == 0)
  1607.                return 0;   /* assume non-structure type */
  1608.             else
  1609.                return 1;   /* might be a structure (is not C_integer) */
  1610.          default:
  1611.             return 0;
  1612.          }
  1613.       }
  1614.    else {
  1615.       /*
  1616.        * struct, union, or enum.
  1617.        */
  1618.       return 1;
  1619.       }
  1620.    }
  1621.  
  1622. /*
  1623.  * determine if the variable being declared evaluates to an address.
  1624.  */
  1625. static int is_addr(dcltor, modifier)
  1626. struct node *dcltor;
  1627. int modifier;
  1628.    {
  1629.    switch (dcltor->nd_id) {
  1630.       case ConCatNd:
  1631.          /*
  1632.           * pointer?
  1633.           */
  1634.          if (dcltor->u[0].child != NULL)
  1635.             modifier = '*';
  1636.          return is_addr(dcltor->u[1].child, modifier);
  1637.       case PrimryNd:
  1638.          /*
  1639.           * We have reached the name.
  1640.           */
  1641.          switch (modifier) {
  1642.             case '\0':
  1643.                return 0;
  1644.             case '*':
  1645.             case '[':
  1646.                return 1;
  1647.             case ')':
  1648.                errt1(dcltor->tok,
  1649.                   "declare {...} should not contain a prototype");
  1650.             }
  1651.       case PrefxNd:
  1652.          /*
  1653.           * (...)
  1654.           */
  1655.          return is_addr(dcltor->u[0].child, modifier);
  1656.       case BinryNd:
  1657.          /*
  1658.           * function or array.
  1659.           */
  1660.          return is_addr(dcltor->u[0].child, dcltor->tok->tok_id);
  1661.       }
  1662.    err1("rtt internal error detected in function is_addr()");
  1663.    /* NOTREACHED */
  1664.    }
  1665.  
  1666. /*
  1667.  * chgn_ploc - if this is an "in-place" conversion to a C value, change
  1668.  *  the "location" of the parameter being converted.
  1669.  */
  1670. static novalue chng_ploc(cnv_typ, src)
  1671. struct node *cnv_typ;
  1672. struct node *src;
  1673.    {
  1674.    int loc;
  1675.  
  1676.    /*
  1677.     * Note, we know this is a valid conversion, because it got through
  1678.     *  pass 1.
  1679.     */
  1680.    loc = PrmTend;
  1681.    if (cnv_typ->nd_id == PrimryNd)
  1682.       switch (cnv_typ->tok->tok_id) {
  1683.          case C_Integer:
  1684.             loc = PrmInt;
  1685.             break;
  1686.          case C_Double:
  1687.             loc = PrmDbl;
  1688.             break;
  1689.          case C_String:
  1690.             loc = PrmCStr;
  1691.             break;
  1692.          }
  1693.    else {   /* must be exact conversion */
  1694.       if (cnv_typ->tok->tok_id == C_Integer)
  1695.          loc = PrmInt;
  1696.       }
  1697.    if (loc != PrmTend)
  1698.       src->u[0].sym->u.param_info.cur_loc = loc;
  1699.    }
  1700.  
  1701. /*
  1702.  * cnt_bufs - See if we need to allocate a string or cset buffer for
  1703.  *  this conversion.
  1704.  */
  1705. static novalue cnt_bufs(cnv_typ)
  1706. struct node *cnv_typ;
  1707.    {
  1708.    if (cnv_typ->nd_id == PrimryNd)
  1709.       switch (cnv_typ->tok->tok_id) {
  1710.          case Tmp_string:
  1711.             ++n_tmp_str;
  1712.             break;
  1713.          case Tmp_cset:
  1714.             ++n_tmp_cset;
  1715.             break;
  1716.          }
  1717.    }
  1718.  
  1719. /*
  1720.  * mrg_abstr - merge (join) types of abstract returns on two execution paths.
  1721.  *   The type lattice has three levels: NoAbstr is bottom, SomeType is top,
  1722.  *   and individual types form the middle level.
  1723.  */
  1724. static int mrg_abstr(sum, typ)
  1725. int sum;
  1726. int typ;
  1727.    {
  1728.    if (sum == NoAbstr)
  1729.       return typ;
  1730.    else if (typ == NoAbstr)
  1731.       return sum;
  1732.    else if (sum == typ)
  1733.       return sum;
  1734.    else
  1735.       return SomeType;
  1736.    }
  1737. #endif                    /* Rttx */
  1738.